home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tj50dsk1.zip / LISTTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1989-01-31  |  16KB  |  435 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.00                              }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  ListTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {$S-,R-,V-,D-}       
  18.  
  19. Unit ListTTT5;
  20.  
  21. interface
  22.  
  23. Uses CRT, DOS, FastTTT5, WinTTT5, KeyTTT5, StrnTTT5;
  24.  
  25. const
  26.      Max_Topics = 255;
  27.  
  28. Type
  29.    Choices = array[1..Max_Topics] of boolean;
  30.    {$IFDEF VER50}
  31.     List_Hook = Procedure(var Ch: char; HiPick:byte);
  32.    {$ENDIF}
  33.    L_Display = record
  34.                      X           : byte;             {top X coord}
  35.                      Y           : byte;             {top Y coord}
  36.                      LeftSide    : Boolean;          {X,Y is leftside of box}
  37.                      Lines       : byte;             {max no of lines to display in box}
  38.                      TopicWidth  : byte;             {width of the slection bar}
  39.                      AllowEsc    : boolean;          {allow the user to escape?}
  40.                      BoxType     : byte;             {single,double etc}
  41.                      BoxFCol     : byte;             {Border foreground color}
  42.                      BoxBCol     : byte;             {Border background color}
  43.                      CapFCol     : byte;             {Capital letter foreground color}
  44.                      BacCol      : byte;             {menu background color}
  45.                      NorFCol     : byte;             {normal foreground color}
  46.                      HiFCol      : byte;             {highlighted topic foreground color}
  47.                      HiBCol      : byte;             {highlighted topic background color}
  48.                      LeftChar    : char;             {left-hand topic highlight character}
  49.                      RightChar   : char;             {right-hand topic highlight character}
  50.                      ToggleChar  : char;             {indicates if a topic has been selected}
  51.                      AllowToggle : Boolean;          {can user select more than one topic}
  52.                      End_Chars   : set of char;      {end of input chars}
  53.                      Select_Chars: set of char;      {keys for user to select topic}
  54.                      {$IFDEF VER50}
  55.                      Hook: List_Hook; {a procedure called after every key is pressed}
  56.                      {$ENDIF}
  57.                end;
  58.  
  59. Var
  60.    LTTT    : L_Display;
  61.    L_Picks : Choices;
  62.    L_Char  : Char;
  63.    L_Pick  : Byte;
  64.    {$IFNDEF VER50}
  65.    L_UserHook  : pointer;
  66.    {$ENDIF}
  67.  
  68. Procedure Default_Settings;
  69. Procedure Show_List(var StrArray;StrLength:Byte;TotalPicks:byte);
  70.  
  71. IMPLEMENTATION
  72. const
  73.     Default_Display_Lines = 10;
  74.     Default_Y1            = 7;
  75.  
  76.   {$IFDEF VER50}
  77.   {$F+}
  78.   Procedure No_Hook(var Ch: char; HiPick :byte);
  79.   {}
  80.   begin
  81.   end; {of proc No_Hook}
  82.   {$F-}
  83.   {$ENDIF}
  84.  
  85.   Procedure Default_Settings;
  86.   begin
  87.       with LTTT do
  88.       begin
  89.           AlloWEsc := true;
  90.           X := 0;
  91.           Y := 0;
  92.           LeftSide := true;
  93.           BoxType      := 1;
  94.           Lines := 0;
  95.           TopicWidth   := 0;
  96.           If BaseOfScreen = $B800 then
  97.           begin
  98.               BoxFCol      := yellow;
  99.               BoxBCol      := blue;
  100.               CapFCol      := White;
  101.               BacCol       := blue;
  102.               NorFCol      := lightgray;
  103.               HiFCol       := white;
  104.               HiBCol       := red;
  105.           end
  106.           else
  107.           begin
  108.               BoxFCol      := white;
  109.               BoxBCol      := black;
  110.               CapFCol      := White;
  111.               BacCol       := black;
  112.               NorFCol      := lightgray;
  113.               HiFCol       := white;
  114.               HiBCol       := black;
  115.           end;
  116.           LeftChar     := Chr(16);
  117.           RightChar    := Chr(17);
  118.           ToggleChar   := Chr(251);
  119.           AllowToggle  := true;
  120.           End_Chars    := [#13];
  121.           Select_Chars := [' '];
  122.           {$IFDEF VER50}
  123.           Hook := No_Hook;
  124.           {$ELSE}
  125.           L_UserHook := nil;
  126.           {$ENDIF}
  127.       end;  {with}
  128.   end;  {Default_Settings}
  129.  
  130.   {$IFNDEF VER50}
  131.    Procedure CallFromListUserHook(var Ch:char;Hipick:byte);
  132.              Inline($FF/$1E/L_UserHook);
  133.   {$ENDIF}
  134.  
  135.  Procedure Show_List(var StrArray;StrLength:Byte;TotalPicks:byte);
  136.  {}
  137.  var
  138.    X1,Y1,X2,Y2 : byte;
  139.    ListWidth   : byte;
  140.    ListLines   : byte;
  141.    TopPick     : byte;
  142.    HiPick      : byte;
  143.    Selected    : Choices;
  144.    Finished    : boolean;
  145.    Scrolling   : boolean;
  146.    ChL         : char;
  147.  
  148.          Function TopicStr(StrNo:byte): StrScreen;
  149.          {searches through string array and returns the string}
  150.          var
  151.            W : word;
  152.            TempStr : String;
  153.            ArrayOffset: word;
  154.          begin
  155.              W := pred(StrNo) * succ(StrLength);
  156.              ArrayOffset := Ofs(StrArray) + W;
  157.              Move(Mem[Seg(StrArray):ArrayOffset],TempStr,1);            {string length in byte 0}
  158.              Move(Mem[Seg(StrArray):succ(ArrayOffset)],TempStr[1],ord(TempStr[0]));
  159.              TopicStr := TempStr;
  160.          end; {of func TopicStr}
  161.  
  162.          Procedure Write_Topic(TopicNo:word;Hilight:boolean);
  163.          {}
  164.          var
  165.            A, Y : byte;
  166.            Tick : char;
  167.          begin
  168.              Y := Succ(Y1) + TopicNo - TopPick;
  169.              If Selected[TopicNo] then
  170.                 Tick := LTTT.ToggleChar
  171.              else
  172.                 Tick := ' ';
  173.              If HiLight then
  174.                 Fastwrite(succ(X1),Y,
  175.                           attr(LTTT.HiFCol,LTTT.HiBCol),
  176.                           LTTT.LeftChar+Tick+' '+padleft(TopicStr(TopicNo),ListWidth,' ')+LTTT.RightChar)
  177.              else
  178.                 Fastwrite(succ(X1),Y,
  179.                           attr(LTTT.NorFCol,LTTT.BacCol),
  180.                           ' '+Tick+' '+padleft(TopicStr(TopicNo),ListWidth,' ')+' ');
  181.          end; {of proc Write_Topic}
  182.  
  183.          Procedure Compute_Topic_Width;
  184.          {}
  185.          var
  186.            I : word;
  187.            W : Byte;
  188.          begin
  189.              ListWidth := 0;
  190.              For I := 1 To TotalPicks do
  191.              begin
  192.                  W := length(TopicStr(I));
  193.                  If ListWidth < W then
  194.                     ListWidth := W;
  195.              end;
  196.              Inc(ListWidth);  {add one char space to right}
  197.          end; {of proc Compute_Topic_Width}
  198.  
  199.          Procedure Compute_Coords;
  200.          {determines the X Y coords of the list box}
  201.          begin
  202.              With LTTT do
  203.              begin
  204.                  If TopicWidth <> 0 then
  205.                     ListWidth := TopicWidth
  206.                  else
  207.                     Compute_Topic_Width;
  208.                  ListWidth := ListWidth + 6;
  209.                  If Lines <> 0 then
  210.                     ListLines := Lines
  211.                  else
  212.                     ListLines := Default_Display_Lines;
  213.                  If ListLines > TotalPicks then
  214.                     ListLines := TotalPicks;
  215.                  If X <> 0 then
  216.                  begin
  217.                      If LeftSide then
  218.                      begin
  219.                          X1 := X;
  220.                          X2 := X1 + Pred(ListWidth);
  221.                      end
  222.                      else
  223.                      begin
  224.                          X2 := X;
  225.                          X1 := X2 - pred(ListWidth);
  226.                      end;
  227.                  end
  228.                  else
  229.                  begin
  230.                      X1 :=  (80 - ListWidth) div 2;
  231.                      X2 :=   X1 + Pred(ListWidth);
  232.                  end;
  233.                  If Y <> 0 then
  234.                      Y1 := Y
  235.                  else
  236.                      Y1 := Default_Y1;
  237.                  If Y1 + succ(ListLines) > DisplayLines then
  238.                  begin
  239.                      Y2 := DisplayLines;
  240.                      ListLines := Y2 - succ(Y1);
  241.                  end
  242.                  else
  243.                      Y2 :=  Y1 + Succ(ListLines);
  244.                  ListWidth := ListWidth - 6;    {set to actual topic width}
  245.                  If ListLines < TotalPicks then
  246.                     Scrolling := true
  247.                  else
  248.                     Scrolling := false;
  249.              end;  {with LTTT}
  250.          end; {of proc Compute_Coords}
  251.  
  252.          Procedure Draw_List_Box;
  253.          {}
  254.          begin
  255.              with LTTT do
  256.              begin
  257.                  Box(X1,Y1,X2,Y2,BoxFCol,BoxBCol,BoxType);
  258.                  ClearText(succ(X1),Succ(Y1),Pred(X2),Pred(Y2),NorFcol,BacCol);
  259.              end; {with}
  260.          end; {of proc Draw_List_Box}
  261.  
  262.          Procedure Set_Parameters;
  263.          {}
  264.          var I : integer;
  265.          begin
  266.              For I := 1 to Max_Topics do
  267.                  Selected[I] := false;
  268.              TopPick := 1;
  269.              HiPick := 1;
  270.          end; {of proc Set_Parameters}
  271.  
  272.          Procedure Display_More;
  273.          {}
  274.          var A : byte;
  275.          begin
  276.              If Scrolling then
  277.              begin
  278.                     A := attr(LTTT.BoxFCol,LTTT.BoxBCol);
  279.                     If TopPick > 1 then
  280.                        Fastwrite(X2,Succ(Y1),A,chr(24))
  281.                     else
  282.                        VertLine(X2,Succ(Y1),Succ(Y1),LTTT.BoxFcol,LTTT.BoxBCol,Lttt.Boxtype);
  283.                     If TopPick + Pred(ListLines) < TotalPicks then
  284.                        Fastwrite(X2,Pred(Y2),A,chr(25))
  285.                     else
  286.                        VertLine(X2,Pred(Y2),Pred(Y2),LTTT.BoxFcol,LTTT.BoxBCol,Lttt.Boxtype);
  287.              end;
  288.          end; {of proc Display_More}
  289.  
  290.          Procedure Display_All_Topics;
  291.          {}
  292.          var  I : Integer;
  293.          begin
  294.              For I := TopPick to TopPick+pred(ListLines) do
  295.                  Write_Topic(I,false);
  296.              Write_Topic(HiPick,True);
  297.              Display_More;
  298.          end; {of proc Display_All_Topics}
  299.  
  300.  begin
  301.      Set_Parameters;
  302.      Compute_Coords;
  303.      Draw_List_Box;
  304.      Display_All_Topics;
  305.      Finished := false;
  306.      Repeat
  307.           ChL := GetKey;
  308.           {$IFDEF VER50}
  309.           LTTT.Hook(ChL,HiPick);
  310.           {$ELSE}
  311.           If L_UserHook <> nil then
  312.              CallFromListUserHook(ChL,HiPick);
  313.           {$ENDIF}
  314.           If ChL in LTTT.End_Chars then
  315.              Finished := true
  316.           else
  317.               If ChL <> #0 then
  318.               If (ChL in LTTT.Select_Chars) and LTTT.AllowToggle then
  319.               begin
  320.                    Selected[HiPick] := not Selected[HiPick];
  321.                    Write_Topic(HiPick,True);
  322.               end
  323.               else
  324.                  Case UpCase(ChL) of
  325.                  #132,
  326.                  #027: If LTTT.AllowEsc then       {Esc}
  327.                           Finished := True;
  328.                  #129,                             {Mouse_Down}
  329.                  #208: begin                       {Down_Arrow}
  330.                            Write_Topic(HiPick,False);
  331.                            If HiPick < TotalPicks then
  332.                               Inc(HiPick)
  333.                            else
  334.                               If (Scrolling = false) and (Chl <> #129) then
  335.                                  HiPick := 1;
  336.                            If HiPick > TopPick + Pred(ListLines) then
  337.                            begin
  338.                                Inc(TopPick);
  339.                                Display_All_Topics;
  340.                            end
  341.                            else
  342.                               Write_Topic(HiPick,True);
  343.                        end;
  344.                  #128,                             {Mouse_Up}
  345.                  #200: begin                       {Up_Arrow}
  346.                            Write_Topic(HiPick,False);
  347.                            If HiPick > 1 then
  348.                               Dec(HiPick)
  349.                            else
  350.                               If (Scrolling = false) and (Chl <> #128) then
  351.                                  HiPick := TotalPicks;
  352.                            If HiPick < TopPick then
  353.                            begin
  354.                                Dec(TopPick);
  355.                                Display_All_Topics;
  356.                            end
  357.                            else
  358.                               Write_Topic(HiPick,True);
  359.                        end;
  360.                  #199: If HiPick <> 1 then       {Home}
  361.                        begin
  362.                            HiPick := 1;
  363.                            TopPick := 1;
  364.                            Display_All_Topics;
  365.                        end;
  366.                  #207: If HiPick <> TotalPicks then   {end}
  367.                        begin
  368.                            HiPick := TotalPicks;
  369.                            TopPick := HiPick - pred(ListLines);
  370.                            Display_All_Topics;
  371.                        end;
  372.                  #201: If Scrolling then   {PgUp}
  373.                        begin
  374.                           If HiPick > ListLines then
  375.                           begin
  376.                              HiPick := HiPick - ListLines;
  377.                              If TopPick > ListLines then
  378.                                 TopPick := TopPick - ListLines
  379.                              else
  380.                                 TopPick := 1;
  381.                           end
  382.                           else
  383.                           begin
  384.                              HiPick := 1;
  385.                              TopPick := 1;
  386.                           end;
  387.                           Display_All_Topics;
  388.                       end
  389.                       else
  390.                       begin
  391.                           If HiPick > 1 then
  392.                           begin
  393.                               Write_Topic(HiPick,False);
  394.                               HiPick := 1;
  395.                               Write_Topic(HiPick,True);
  396.                           end;
  397.                       end;
  398.                  #209:If Scrolling then   {PgDn}
  399.                       begin
  400.                           If HiPick + ListLines <= TotalPicks then
  401.                           begin
  402.                              HiPick := HiPick + ListLines;
  403.                              If TopPick + ListLines +pred(ListLines) > TotalPicks then
  404.                                 TopPick := TotalPicks - pred(ListLines)
  405.                              else
  406.                                 TopPick := TopPick + ListLines;
  407.                           end
  408.                           else
  409.                           begin
  410.                              HiPick := TotalPicks;
  411.                              TopPick := TotalPicks - pred(ListLines);
  412.                           end;
  413.                           Display_All_Topics;
  414.                       end
  415.                       else
  416.                       begin
  417.                           If HiPick < TotalPicks then
  418.                           begin
  419.                               Write_Topic(HiPick,False);
  420.                               HiPick := TotalPicks;
  421.                               Write_Topic(HiPick,True);
  422.                           end;
  423.                       end;
  424.                  end;  {case}
  425.      Until Finished;
  426.      L_Char := ChL;
  427.      L_Picks := Selected;
  428.      L_Pick := HiPick;
  429.  end; {of proc Show_List}
  430.  
  431.  
  432. begin
  433.     Default_Settings;
  434. end.
  435.